CD ROM Paradise Collection 4

home *** CD-ROM | disk | FTP | other *** search

/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / pcfig4th.zip / FILES.SCR < prev next >

Wrap

Text File | 1985-04-23 | 20KB | 35 lines

-+- MS-DOS File -+ +- Interface -+- Note: these screens must be loaded from a FORTH disk! ( strings: ", ["] ) : " ( accept text delimited by " to PAD with count ) 34 WORD PAD C/L BLANKS HERE PAD HERE C@ 1+ CMOVE ; : (") ( moves text in definition to PAD ) PAD C/L BLANKS R PAD R C@ 1+ R> OVER + >R CMOVE ; : [" ( as ", but get text in definition, then to PAD at exec ) COMPILE (") 34 WORD HERE C@ 1+ ALLOT ; IMMEDIATE --> ( error handling: ABORT" ) : (AB") PAD COUNT TYPE SP! QUIT ; : ABORT" ( f -- ;abort execution and type a message ) ( if f is TRUE ) [COMPILE] IF [COMPILE] [" COMPILE (AB") [COMPILE] THEN ; IMMEDIATE ( MS-DOS file interface: support words, FNAME ) : @FCB 2+ ; ( fd -- FCB ; advances fd to start of FCB) : @FSIZE 16 + ; ( FCB -- FCB.SIZE ; returns addr of size field) : FNAME ( addr mode -- afn ; parse word at PAD as a filename ) ( afn is true if filename is ambiguous ) ( Mode determines defaults for MS-DOS function 29H) ( Parsed file name, drive+11 bytes, is left at addr) PAD 1+ SWAP (FNAME) ( -- addr' afn ) SWAP PAD 1+ - PAD C@ = 0= HEX 4000 PAD ! ( mark PAD so the name ) DECIMAL ( can't be used accidentally ) ABORT" ? Illegal filename" ; --> ·3└Ä╪Ä└Ä╨╝ⁿ┐╣@│░╨µα╘ ╘ ╘ ╘ Ç√v ░XΦ0Çδδ±è├µΓ║πW░êµαδ¬Σσ╨╚∞s°_Φ$£u╟ü╟■├Γ┐Ω@µα╘ ΣΣ¿t·Σα├·3└Ä╪Ä└Ä╨╝ⁿ┐╣│░╨µα╘ ╘ ╘ ╘ Ç√v ░XΦ@Çδδ±è├┤<v,┤µΓè─µΣ║πW░êµαδ¬Σσ╨╚∞s°_Φ$£u╖ü╟Ç■├Γ»Ω@µα╘ ΣΣ¿t·Σα├NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN÷÷÷ⁿNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN⌡⌡⌡■'≈NNNNNNNNNNNNNNNNNNNNNN⌡⌡⌡√σσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσ° @`Ç ≡ └α @`Çá└α! #@ o'Ç)á+└-α/1 3≡ 5`7Ç9á;└=α?A C@E`GÇIáK└Mα Q S@U`WÇYá[└]α_a c@e`gÇiák└mαoq s@u`wÇyá{└}αü â@à`çÇëáï└ìαÅ æ ô@ ò` ùÇ Öá ¢└ ¥α ƒ í O Ñ` ºÇ ⌐á ½└ ¡α »▒ │@╡`╖Ç »╗└╜α┐┴ ├@┼`╟Ç╔á ╧═α╧╤ ╙@╒`╫Ç┘á█└▌α▀ß π@σ`τÇΘáδ└φα∩± ≤@⌡`≈Ç∙á√└²α !Aaü í┴ß ! Oaüí┴ß!!#A%a'ü)í+┴-ß/1!3A5a7ü9í 28 ;=U BLK current block, 0 if te° @`Ç ≡ └α @`Çá└α! #@ o'Ç)á+└-α/1 3≡ 5`7Ç9á;└=α?A C@E`GÇIáK└Mα Q S@U`WÇYá[└]α_a c@e`gÇiák└mαoq s@u`wÇyá{└}αü â@à`çÇëáï└ìαÅ æ ô@ ò` ùÇ Öá ¢└ ¥α ƒ í O Ñ` ºÇ ⌐á ½└ ¡α »▒ │@╡`╖Ç »╗└╜α┐┴ ├@┼`╟Ç╔á ╧═α╧╤ ╙@╒`╫Ç┘á█└▌α▀ß π@σ`τÇΘáδ└φα∩± ≤@⌡`≈Ç∙á√└²α !Aaü í┴ß ! Oaüí┴ß!!#A%a'ü)í+┴-ß/1!3A5a7ü9í 28 ;=U BLK current block, 0 if teREADME ,EFORTH COMk 154TH COM≡%─PCFORTH COM⌠ú4╥4ASM SCR┴≤O¿FUTIL SCR╘ ú,UTIL SCROÜ⌠╣$SCREENEDSCR╪╝╦êCASE SCR≤FILES SCRÅ≤Pσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσσ--> ( MS-DOS file interface: /CREATE /OPEN /CLOSE ) : /CREATE ( fd -- ; create and open fd ) DUP ?SHUT DUP ?WRITE DUP @FCB 12 + FCBSIZE 12 - ERASE DUP @FCB (CREATE) ABORT" ? Can't create file" OPN TOGGLE ; : /OPEN ( fd -- ; open fd ) DUP ?SHUT DUP @FCB 12 + FCBSIZE 12 - ERASE DUP @FCB (OPEN) ABORT" ? File doesn't exist" OPN TOGGLE ; : /CLOSE ( fd -- ; close fd ) DUP @FCB (CLOSE) ABORT" ? Can't close file, did you change disks?" DUP @ -1 OPN - AND SWAP ! ; --> ( MS-DOS file interface: /READ /WRITE ) : /READ ( fd addr n -- f ; READ n bytes from file fd to addr ) ROT DUP ?READ DUP ?OPEN DUP ?CHAR SWAP OVER ( addr fd n fd ) /SETSIZE @FCB SWAP (READ) ; : /WRITE ( addr n fd -- f ; WRITE n bytes from addr to fd ) DUP ?WRITE DUP ?OPEN DUP ?CHAR SWAP OVER /SETSIZE @FCB SWAP (WRITE) ; --> ( NOTE: n should not be varied between reads/writes ! ) ( The file pointer maintained by MSDOS is in terms of the ) ( record size being used, and changing the record size without) ( adjusting the pointer causes problems... ) ( MS-DOS file interface: /GETC /PUTC ) 0 VARIABLE [C] : /GETC ( fd -- c ; get char c from file fd ) [C] 1 /READ IF 0 ELSE [C] @ THEN ; : /PUTC ( c fd -- f ; write c to fd, f is TRUE on error ) SWAP [C] ! [C] 1 ROT /WRITE ; --> ( MS-DOS file interface: /BLKS ) : /BLKS ( fd -- n ; leaves no. B/BUF sized blocks in file. ) ( ABORTS if <filesize>/<B/BUF> is not an integer ) DUP ?OPEN DUP @FCB @FSIZE 2@ SWAP B/BUF M/ SWAP IF ( rem<>0 ) DROP /CLOSE ( close the file ) ABORT" ? File isn't a screen file" ELSE SWAP DROP THEN ; --> ( MS-DOS file interface: SCREENS, /BLOCK-READ, WRITE ) RD WRT + SCRNS + FILE SCREENS ( fd for screens ) ( The following functions do no error checking because BLOCK ) ( becomes really fouled up if it ABORTS before finishing ! ) : /BLOCK-READ ( addr blk -- ; read BLK from SCREENS ) RECORD ! DTA ! SCREENS @FCB 1 (FBLKRD) DISK-ERROR ! ; : /BLOCK-WRITE ( addr blk -- ; write BLK to SCREENS ) RECORD ! DTA ! SCREENS @FCB 1 (FBLKWRT) DISK-ERROR ! ; --> ( MS-DOS file utilities: FCB display primitives ) : .DRIVE ( addr -- ; print addr as drive A-Z ) C@ 64 + EMIT 58 EMIT ; : .FNAME ( addr -- ; print filename at addr ) DUP 8 TYPE 46 EMIT 8 + 3 TYPE SPACE ; : .FSIZE ( addr -- ; print size ) 2@ SWAP 10 D.R 2 SPACES ; : 2DIGS 0 <# # # #> TYPE ; : .MO @ 480 AND 32 / 2DIGS 45 EMIT ; : .DAY @ 31 AND 2DIGS 45 EMIT ; : .YR 1+ C@ 2 / 1980 + 0 <# # # # # #> TYPE 2 SPACES ; --> ( MS-DOS file utilities: fd display /? ) : .DATE ( addr -- ; print date stamp ) DUP .MO DUP .DAY .YR ; : .HR 1+ C@ 248 AND 8 / 2 .R 58 EMIT ; : .MIN @ 2016 AND 32 / 2DIGS 2 SPACES ; : .TIME DUP .HR .MIN ; ( addr -- ;print time stamp ) : /? ( fd -- ; print status of file ) CR DUP @FCB DUP .DRIVE DUP 1+ .FNAME >R DUP @ RD AND IF 114 ELSE 45 THEN EMIT SPACE DUP @ WRT AND IF 119 ELSE 45 THEN EMIT SPACE DUP @ SCRNS AND IF 115 ELSE 99 THEN EMIT SPACE @ OPN AND IF R 16 + .FSIZE R 20 + .DATE R> 22 + .TIME ELSE R> DROP THEN 2 SPACES ; --> ( MS-DOS file utilities: DIR ) : .DIR ( addr -- ; print directory entry at addr ) DUP >R .DRIVE R 1+ .FNAME R 29 + .FSIZE R 25 + .DATE R> 23 + .TIME SPACE ; --> ( MS-DOS file interface: -SET, EOF ) : -SET ( addr blk -- ;inform user about disk state ) 1 DISK-ERROR ! ( force BLOCK to abort ) CR ." Specify disk access mode: " CR ." use SWITCH or USING" 34 EMIT 46 EMIT CR ; : EOF ( -- ;quit using screen file, but don't use FORTH disk) FLUSH SCREENS DUP ?OPEN DUP /BLKS ( check # blocks ) SWAP /CLOSE IF ( # blocks >0 ) SCREENS @FCB PAD ?FIRST ABORT" File not in directory!" PAD .DIR ( show the directory entry ) ELSE SCREENS @FCB ." Erasing empty file..." FDEL IF ." couldn't erase " THEN THEN ' -SET CFA DUP @BLKRD ! @BLKWRT ! ; --> ( MS-DOS file interface: SWITCH ) : SWITCH ( -- ;switch to FORTH disk ) SCREENS @ OPN AND IF ( open ) EOF ( close SCREENS ) THEN ' BLKRD CFA @BLKRD ! ' BLKWRT CFA @BLKWRT ! CR CR ." WARNING: Replace MS-DOS disks with FORTH disks " ; : BYE ( -- ;leave FORTH, make sure SCREENS are closed ) SCREENS @ OPN AND IF ( open ) EOF ( close SCREENS ) THEN BYE ; : A: ( -- ;select drive A as the default drive ) 0 DISK DROP ; : B: ( -- ;select drive B as the default drive ) 1 DISK DROP ; --> ( MS-DOS file interface: USING" ) : USING" ( --;set up to use screen file. ) ( usage is USING" filename" ) SCREENS ?SHUT ( only one file at a time! ) [" .SCR" SCREENS @FCB 0 FNAME DROP ( set default = .SCR ) SCREENS @FCB " ( get filename from terminal ) DF-EXT FNAME ( assign name to SCREENS using default ext ) ABORT" no */? allowed" SCREENS @FCB (OPEN) ( try to open it... ) IF ( non-existent ) SCREENS /CREATE ELSE SCREENS OPN TOGGLE THEN ( set open attribute ) SCREENS /BLKS ( check record size, leave # blocks ) 0 WARNING ! ( probably can't find error mesages ) 0 SCREENS /SETREC ( initialize random record field ) B/BUF SCREENS /SETSIZE ( transfer whole buffers ) --> ( MS-DOS file interface: USING", cont. EXTEND ) -DUP IF ( non-empty file ) ." last block in " SCREENS @FCB DUP .DRIVE 1+ DUP 8 -TRAILING TYPE ( print file name ) 46 EMIT 8 + 3 -TRAILING TYPE ( print ext ) ." is " 1- U. ( print filename and number of blocks ) ELSE ." empty file " THEN ' /BLOCK-READ CFA @BLKRD ! ( read from file now ) ' /BLOCK-WRITE CFA @BLKWRT ! ( write to file now ) EMPTY-BUFFERS ; ( don't mix buffers ) : EXTEND ( n -- ;allocate n additional blocks to SCREENS ) SCREENS ?OPEN ( must be using SCREENS ) SCREENS /BLKS + 1- BUFFER ( assign a buffer to last block) UPDATE SAVE-BUFFERS DROP ; ( force it to disk ) --> ( MS-DOS file interface: LOAD" , INDEX" ) : LOAD" ( -- ;load a screen file, can't be nested ) USING" ( get file name and open file ) 0 15 0 DO I OVER CR .LINE ( list screen 0 : title screen ) LOOP DROP CR 1 LOAD ( start loading at screen 1 ) EOF ( quit after LOAD ) ; ;S